# schema2.pl
use strict;
use warnings;

#
#   Infer path index set and schema information of a Perl variable
#

#use Date::Manip::Date;       #this is a huge beast and takes ages to load (is good though!)
#use Data::Types qw(:all);

my $FALSE = 0;
my $TRUE  = 1;

sub detect_types {
    #
    #   ARRAY_REF path_index_set(VARIABLE $value[, HASHREF $options])
    #
    #   Returns an array of JSONPath expressions indexing all sub-terms of Perl variable $value.
    #
    #   Options:
    #       'canonical' => $TRUE    sorts hashes on their keys to ensure canonical order. Default = $TRUE
    #       'pretty' => $TRUE       pretty print with indentation. Default = $TRUE
    #
    my ($value, $options) = @_;
    
    if (!defined $options || ref($options) ne 'HASH') {
        $options = {};
    }

    $options->{'canonical'} = (defined $options->{'canonical'} && $options->{'canonical'} eq "$FALSE") ? $FALSE : $TRUE;
    $options->{'pretty'}    = (defined $options->{'pretty'}    && $options->{'pretty'} eq "$FALSE")    ? $FALSE : $TRUE;
    
    # we overload the options hash to also carry around indentation state information
    $options->{'_indent'} = 0;
    $options->{'_paths'}  = [];     #for efficiency: use global result arrayref to avoid returns having to splice arrays

    if (defined $value && (ref($value) eq 'HASH' || ref($value) eq 'ARRAY' || $value ne '')) {
        $options->{'_indent'}++;
        dt_scan_term_value($value, '$', $options);
    }

    return $options->{'_paths'};
}
=head
sub is_datetime {
    my ($value) = @_;
    my $date = new Date::Manip::Date;
    my $err = $date->parse($value);
    return ($err) ? $FALSE : $TRUE;
}
sub is_date {
    my ($value) = @_;
    my $date = new Date::Manip::Date;
    my $err = $date->parse_date($value);
    return ($err) ? $FALSE : $TRUE;
}
sub is_time {
    my ($value) = @_;
    my $date = new Date::Manip::Date;
    my $err = $date->parse_time($value);
    return ($err) ? $FALSE : $TRUE;
}
=cut

sub dt_scan_term_value {
    my ($value, $stem, $options) = @_;
    if (!defined $value) {
        return;
    }
    elsif (ref($value) eq 'HASH') {
        push(@{$options->{'_paths'}}, [$stem . '.*', 'object', $value]);
        dt_scan_term_hash($value, $stem, $options);
        return;
    }
    elsif (ref($value) eq 'ARRAY') {
        push(@{$options->{'_paths'}}, [$stem . '[*]', 'array', $value]);
        dt_scan_term_array($value, $stem, $options);
        return;
    }
    elsif ($value ne '') {
        my %properties = ();
        my $predicates = ['is_decimal', 'is_int', 'is_whole', 'is_url', 'is_boolean', 'is_html'];
        for my $predicate (@$predicates) {
            no strict 'refs';
            my $result = &$predicate($value);
            use strict 'refs';
            if (defined $result && $result) {
                $properties{$predicate} = 'true';
            }
        }
        push(@{$options->{'_paths'}}, [$stem, 'scalar', $value, \%properties]);
        return;
    }
    return;
}

sub evaluate_type_predicates {
    my ($value) = @_;
}

sub dt_scan_term_hash {
    my ($hash_ref, $stem, $options) = @_;


    my @keys = keys %$hash_ref;
    if ($options->{'canonical'}) {
        @keys = sort @keys;
    }
    $options->{'_nargs' . $options->{'_indent'}} = scalar(@keys);
    for my $key (@keys) {
        my $value = $hash_ref->{$key};
        if ($value ne '') {
            $options->{'_indent'}++;
            $options->{'_nargs' . $options->{'_indent'}} = 0;
            dt_scan_term_value($value, $stem . '.' . dt_atomquote($key), $options);
            $options->{'_indent'}--;
        }
    }
}

sub dt_scan_term_array {
    my ($array_ref, $stem, $options) = @_;

    # schema properties
    my %props = ();

    $options->{'_nargs' . $options->{'_indent'}} = scalar(@$array_ref);
    my $i = 0;
    for my $value (@$array_ref) {
        if ($value ne '') {
            $options->{'_indent'}++;
            $options->{'_nargs' . $options->{'_indent'}} = 0;
            dt_scan_term_value($value, $stem . '[' . $i . ']', $options);
            # generalise schema properties
            my $res = $options->{'_paths'}[-1];
#            if (
##print STDERR $i . " >>> ".Dumper($res);
            $options->{'_indent'}--;
        }
        $i++;
    }
}

sub dt_atomquote {
    my ($str) = @_;
    if (defined $str) {
        if ($str =~ m{[\.\[\]\']}xs) {  #FIXME: can't find formal syntax but apart from pathalogical examples, this works
            $str =~ s/\'/\\\'/gsmx;
            $str = '[\'' . $str . '\']';
        }
    }
    else {
        die 'Undefined string!';
    }
    return $str;
}

sub scan_atom_or_numberXXXX {
    my ($str) = @_;
    if (defined $str) {
        $str =~ s/'/\\'/gsmx;
                    #FIXME: should restrict length/size of numbers to ensure not illegal in Prolog
        if ($str !~ m{^[a-z_][a-zA-Z0-9_]*$|^[+-]?[0-9]+(?:\.[0-9]*)?(?:e[+-][0-9]+)?$}xs) {
            $str =~ s/\n/\\n/gxsm;
            $str = '\'' . $str . '\'';
        }
    }
    else {
        die 'Undefined string!';
    }
    return $str;
}

sub is_boolean {
    my ($value) = @_;
    if (defined $value && $value =~ m{^(?:0|1|true|false)$}xsmio) {
        return $TRUE;
    }
    return $FALSE;
}

#FIXME: this doesn't distinquish between xml, well-formed xml, xml document and html fragment, html document
sub is_html {
    my ($value) = @_;
    if (defined $value) {
        # only look in the first 1000 characters (to avoid massive string searches
        my $start = substr $value, 0, 1000;
        if ($start =~ m{</?[A-Za-z_\-]+>}xsmo || $start =~ m{&#\n+;}xsmo || $start =~ m{&[A-Za-z]+;}xsmo) {
            return $TRUE;
        }
    }
    return $FALSE;
}

#FIXME: this is a pretty basic url recogniser
sub is_url {
    my ($value) = @_;
    if (defined $value && ($value =~ m{^(?:http|https|sftp|ftp)://}xsmo || $value =~ m{^mailto:}xsmo)) {
        return $TRUE;
    }
    return $FALSE;
}

############################## Data::Types

use constant DEF_PRECISION => 5;

################################################################################
# FUNCTIONS                                                                    #
################################################################################

sub is_whole ($) {
    return unless defined $_[0];
    return unless $_[0] =~ /^\d+$/;
    return 1;
}

sub to_whole ($) {
    return unless defined $_[0];
    my ($num) = $_[0] =~ /([+-]?(?:\d+(?:\.\d*)?|\.\d+))/;
    return unless defined $num && $num >= 0;
    sprintf "%.0f", $num;
}

sub is_count ($) {
    return unless $_[0];
    return unless $_[0] =~ /^\d+$/;
    return 1;
}

sub to_count ($) {
    return unless $_[0];
    my ($num) = $_[0] =~ /([+-]?(?:\d+(?:\.\d*)?|\.\d+))/;
    return unless $num && $num > .5;
    sprintf "%.0f", $num;
}

sub is_int ($) {
    return unless defined $_[0] && $_[0] ne '';
    return unless $_[0] =~ /^[+-]?\d+$/;
    return 1;
}

sub to_int ($) {
    return unless defined $_[0] && $_[0] ne '';
    my ($num) = $_[0] =~ /([+-]?(?:\d+(?:\.\d*)?|\.\d+))/;
    return unless defined $num;
    sprintf "%.0f", $num;
}

sub is_decimal ($) {
    return unless defined $_[0] && $_[0] ne '';
    return unless $_[0] =~ /^[+-]?(?:\d+(?:\.\d*)?|\.\d+)$/;
    return 1;
}

sub to_decimal ($;$) {
    return unless defined $_[0] && $_[0] ne '';
    my ($num) = $_[0] =~ /([+-]?(?:\d+(?:\.\d*)?|\.\d+))/;
    return unless defined $num;
    $_[1] ||= DEF_PRECISION;
    sprintf "%.$_[1]f", $num;
}

#sub is_real ($) {
#    return unless defined $_[0] && $_[0] ne '';
#    return unless $_[0] =~ /^[+-]?\d*\.?\d*$/;
#    return 1;
#}

#sub to_real ($) {
#    return unless defined $_[0] && $_[0] ne '';
#    sprintf "%f", $_[0] =~ /([+-]?\d*\.?\d*)/;
#}

# These may need to be separated in the future, in order to identify non-decimal
# real numbers.
*is_real = *is_decimal;
*to_real = *to_decimal;

sub is_float ($) {
    return unless defined $_[0] && $_[0] ne '';
    return unless $_[0] =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
    return 1;
}

sub to_float ($;$) {
    return unless defined $_[0] && $_[0] ne '';
    my ($num) = $_[0] =~ /(([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)/;
    return unless defined $num;
    my $type = $num =~ /e|E/ ? 'e' : 'f';
    $_[1] ||= DEF_PRECISION;
    sprintf "%.$_[1]$type", $num;
#    sprintf "%g", $_[0] =~ /(([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)/;
}

sub is_string ($) { defined $_[0] && ! ref $_[0] }

sub to_string ($;$) {
    return unless defined $_[0];
    return $_[1] ? substr("$_[0]", 0, $_[1]) : "$_[0]";
}

1;
